#lang racket
;; MIT License

;; Copyright (c) 2025 三体自动化技术协会

;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in all
;; copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;; https://gitee.com/wu-org/isa/blob/master/Tao6.rkt
;; THIS CORE IT WORKS!
;; 它是游戏《观天道》（https://gitee.com/wu-org/isa/blob/master/doc/GDD.md）的核心。
;; 把本文件的源代码整个复制黏贴给DeepSeek,让DeepSeek告诉你这是什么，它有多逆天，及它是如何工作的。
;; 可通过在当前目录下执行 racket Tao6.rkt 独立验证本模块。
;; 这将会编译——载入——运行下面所定义的 make-test-code 过程所生成的汇编代码。
;; 运行的结果是:
;; “屏幕显示”在frame-buffer.html文件中；
;; 全部机器上下文在coredump.scm文件中；
;; 到一个halt指令为止的指令流水在debug-print.txt文件中。
;; Tao6实验是将Tao5的全部机器上下文编码在一个连续的地址空间里。尽量兼容Tao5上的程序。


;; (require math/number-theory)
(require srfi/13)
(provide
 ;; 供外部查询的常量
 CODE-SEG-BEGIN CODE-SEG-LEN DATA-SEG-BEGIN DATA-SEG-LEN
 STACK-LIMIT MEM-LEN
 FRAME-BUFFER-BEGIN FRAME-BUFFER-WIDTH FRAME-BUFFER-HEIGHT
  ;; 供外部查询的机器上下文
 MEM COINS-REMAIN PC SP REGSTACK CYCLES
 ;; 开放给外部的系统调用
 get-state ;; 给出完整的机器上下文
 set-coins! insert-coin reset-pc! set-pc! set-sp! reset-cycles! render-frame-buffer
 RESET-MACHINE! ASSEMBLE LOAD-BYTECODE! RUN-MACHINE! step-machine! dump-machine
 make-test-code
 )
;; etc
(define dump-file-name                 "coredump.scm")
(define (get-debug-print-file-name) "debug-print.txt")

;; machine constants
(define CODE-SEG-BEGIN      0)
(define CODE-SEG-LEN        1024)
(define DATA-SEG-BEGIN      1024) ; 只要有把握，设成和CODE-SEG-BEGIN相同也可以的
(define DATA-SEG-LEN        256)
(define STACK-LIMIT         32)
(define FRAME-BUFFER-BEGIN (+ DATA-SEG-BEGIN DATA-SEG-LEN))
(define FRAME-BUFFER-WIDTH  64)   ; 屏幕宽
(define FRAME-BUFFER-HEIGHT 64)   ; 屏幕高
(define MEM-LEN
  ;; (+ FRAME-BUFFER-BEGIN (* FRAME-BUFFER-WIDTH FRAME-BUFFER-HEIGHT))
  (* 8 1024))

;; machine context(machine state)
(define MEM (make-vector MEM-LEN 0))
(define COINS-REMAIN 8196) ; 每运行一个周期消耗一个币,你的投币是机器运行的动力！
(define PC         0)
(define SP        -1)
(define REGSTACK (make-vector STACK-LIMIT 0))
(define CYCLES   0)

;; defination of ISA
(define ISA
  (list
   ;;     op             code  args  action
   ;; 0x00-0x0F: 特殊指令
   (list 'NOP            #x00  0 (lambda ()                                                                                (pc+! 1)))
   ;; 0x10-0x1F: 栈操作
   (list 'PUSH           #x10  1 (lambda () (push! (get-arg 1))                                                            (pc+! 2)))
   (list 'POP            #x11  0 (lambda () (pop!)                                                                         (pc+! 1)))
   (list 'DUP            #x12  0 (lambda () (push! (reg-ref SP))                                                           (pc+! 1)))
   (list 'SWAP           #x13  0 (lambda ()        (let* ((a (pop!)) (b (pop!))) (push! a) (push! b))                      (pc+! 1)))
   (list 'OVER           #x14  0 (lambda () (push! (reg-ref (- SP 1)))                                                     (pc+! 1)))
   (list 'IIF            #x15  0 (lambda () (push! (let* ((op3 (pop!)) (op2 (pop!)) (op1 (pop!)))
                                                                                     (if (not (= op1 0)) op2 op3)))        (pc+! 1)))
   ;; 0x20-0x2F: 算术运算
   (list 'ADD            #x20  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!)))    (regularized-number (+ op1 op2)))) (pc+! 1)))
   (list 'SUB            #x21  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!)))    (regularized-number (- op1 op2)))) (pc+! 1)))
   (list 'MUL            #x22  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!)))    (regularized-number (* op1 op2)))) (pc+! 1)))
   (list 'DIV            #x23  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!)))
                                                     (if (= 0 op2)
                                                         (random MEM-LEN)               (regularized-number (/ op1 op2)))))(pc+! 1)))
   (list 'MOD            #x24  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!)))
                                                     (if (= 0 op2) (random MEM-LEN) (modulo op1 op2))))                 (pc+! 1)))
   (list 'INC            #x25  0 (lambda () (push! (let* ((op1 (pop!)))                 (regularized-number (+ op1   1)))) (pc+! 1)))
   (list 'DEC            #x26  0 (lambda () (push! (let* ((op1 (pop!)))                 (regularized-number (- op1   1)))) (pc+! 1)))
   ;; 0x30-0x3F: 位运算
   (list 'AND            #x30  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (bitwise-and op1 op2)))               (pc+! 1)))
   (list 'OR             #x31  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (bitwise-ior op1 op2)))               (pc+! 1)))
   (list 'NOT            #x32  0 (lambda () (push! (let* ((op1 (pop!)))              (bitwise-not op1)))                   (pc+! 1)))
   ;; 0x40-0x4F: 比较运算
   (list 'EQ             #x40  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if      (= op1 op2)  1 0)))          (pc+! 1)))
   (list 'NEQ            #x41  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if (not (= op1 op2)) 1 0)))          (pc+! 1)))
   (list 'GT             #x42  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if     (>  op1 op2)  1 0)))          (pc+! 1)))
   (list 'GTE            #x43  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if     (>= op1 op2)  1 0)))          (pc+! 1)))
   (list 'LT             #x44  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if     (<  op1 op2)  1 0)))          (pc+! 1)))
   (list 'LTE            #x45  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (if     (<= op1 op2)  1 0)))          (pc+! 1)))
   ;; 0x50-0x5F: 内存操作
   (list 'STORE          #x50  0 (lambda () (let* ((val (pop!)) (addr (pop!))) (set-data! addr val))                       (pc+! 1)))
   (list 'LOAD           #x51  0 (lambda () (let* ((addr (pop!))) (push! (get-data addr)))                                 (pc+! 1)))
   (list 'COPY           #x52  0 (lambda () (let* ((addr2 (pop!)) (addr1 (pop!))) (set-data! addr2 (get-data addr1)))      (pc+! 1)))
   ;; 0x60-0x6F: 控制流
   (list 'JUMP           #x60  1 (lambda ()                        (set-pc! (get-arg 1))))
   (list 'JUMPIF         #x61  1 (lambda () (if (not (= (pop!) 0)) (set-pc! (get-arg 1))                                   (pc+! 2))))
   (list 'JUMPIF-NOT     #x62  1 (lambda () (if      (= (pop!) 0)  (set-pc! (get-arg 1))                                   (pc+! 2))))
   (list 'JUMP-REL       #x63  1 (lambda ()                                                                                (pc+! (get-arg 1))))
   (list 'CALL           #x64  1 (lambda () (push! (+ PC 2))       (set-pc! (get-arg 1))))
   (list 'RET            #x65  0 (lambda ()                        (set-pc! (pop!))))
   (list 'CALLIF         #x66  1 (lambda () (if (not (= (pop!) 0)) (begin (push! (+ PC 2))(set-pc! (get-arg 1)))           (pc+! 2))))
   ;; 0x70-0x7F: I/O操作
   (list 'PRINT          #x70  0 (lambda () (display (pop!)) (display #\newline)                                           (pc+! 1)))
   (list 'SET-UNICODE    #x71  0 (lambda () (let* ((op3 (pop!)) (op2 (pop!)) (op1 (pop!))) (set-unicode! op1 op2 op3)      (pc+! 1))))
   (list 'GET-UNICODE    #x72  0 (lambda () (push! (let* ((op2 (pop!)) (op1 (pop!))) (get-unicode op1 op2)                 (pc+! 1)))))
   ;; 0x80-0x8F: 系统功能
   (list 'RANDOM         #x80  0 (lambda () (push! (let* ((op1 (pop!)))              (random op1)))                        (pc+! 1)))
   (list 'TIME           #x81  0 (lambda () (push! (current-seconds))                                                      (pc+! 1)))
   ;; HALT 0xff
   (list 'HALT           #xff  0 (lambda ()                                                                                (pc+! 1)))))

;; basic facility
(define (set-coins! n)  (when (not (= n COINS-REMAIN)) (set! COINS-REMAIN n) (dump-machine) ))
(define (insert-coin n) (set-coins! (+ COINS-REMAIN n)))
(define (reset-cycles!) (set! CYCLES 0) (dump-machine))
(define (reset-pc!)     (set! PC 0)     (dump-machine))
(define (ragularized mod-n) (lambda (x) (modulo (inexact->exact (truncate x)) mod-n)))
(define (regularized-number   x) ((ragularized               65536) x))
(define (regularized-addr     x) ((ragularized             MEM-LEN) x))
(define (regularized-screen-x x) ((ragularized  FRAME-BUFFER-WIDTH) x))
(define (regularized-screen-y y) ((ragularized FRAME-BUFFER-HEIGHT) y))
(define (reg-ref n)         (if (<= 0 n (- STACK-LIMIT 1)) (vector-ref  REGSTACK n) (random MEM-LEN)))
(define (stack-top-ref)     (reg-ref SP))
(define (set-sp! n)         (set! SP n))
(define (sp++!)             (set-sp! (+ SP 1)))
(define (sp--!)             (set-sp! (- SP 1)))
(define (push! x)           (sp++!)         (vector-set! REGSTACK (modulo SP STACK-LIMIT) x))
(define (pop!)              (let ((top (stack-top-ref))) (sp--!) top))
(define (set-pc! n)         (set! PC n) PC)
(define (pc+!    n)         (set-pc! (+ PC n)))
(define (read-code addr)    (vector-ref MEM (+ addr CODE-SEG-BEGIN)))
(define (get-arg n)         (read-code (+ n PC)))
(define (get-data addr)     (vector-ref  MEM (regularized-addr (+ addr DATA-SEG-BEGIN))))
(define (set-data! addr val)(vector-set! MEM (regularized-addr (+ addr DATA-SEG-BEGIN)) val))
(define (get-instr)         (modulo (read-code PC) 256))
(define (set-unicode! x y code)     (vector-set! MEM (+ (* (regularized-screen-y y) FRAME-BUFFER-WIDTH)
                                                        (regularized-screen-x x)
                                                        FRAME-BUFFER-BEGIN)
                                                 (modulo code #x10000)))
(define (get-unicode x y)           (modulo
                                     (vector-ref  MEM (+ (* (regularized-screen-y y) FRAME-BUFFER-WIDTH)
                                                         (regularized-screen-x x)
                                                         FRAME-BUFFER-BEGIN))
                                     #x10000))
(define (render-frame-buffer)
  (define html-file "frame-buffer.html")
  (define (unicode-char->html unicode)
    (let ((uchar
           (if (<= #xD800 unicode #xDFFF)
               #\space
               (integer->char (modulo unicode 65536)))))
      (cond
        ((char-whitespace? uchar) "&nbsp;")
        ((char=? uchar #\<) "&lt;")
        ((char=? uchar #\>) "&gt;")
        ((char=? uchar #\&) "&amp;")
        (else (string uchar)))))
  (call-with-output-file html-file
    (lambda (out)
      (display "<table id=\"FRAME-BUFFER\">" out)
      ; 生成表格行和列
      (for ([y (in-range FRAME-BUFFER-HEIGHT)])
        (display "<tr>" out)
        (for ([x (in-range FRAME-BUFFER-WIDTH)])
          (let* ((unicode (get-unicode x y))
                 (char-display (unicode-char->html unicode)))
            (display (format "<td>~a</td>" char-display) out)))
        (display "</tr>\n" out))
      (display "</table>" out))
    #:exists 'replace)
(displayln (format "HTML文件已生成: ~a" html-file)))



(define HALT-OPCODE (cadr (assoc 'HALT ISA)))
(define cdr-mapped-ISA (map cdr ISA))

(define (ASSEMBLE list-of-code)
  (define ALIAS_MAP '((P PUSH) (PP POP)
                    (+ ADD)(- SUB) (* MUL) (/ DIV) (% MOD)
                    (= EQ) (> GT) (< LT)
                    (& AND) (~ NOT)
                    (CP COPY)
                    (JMP JUMP)
                    (SETU SET-UNICODE)
                    (HLT HALT)
                    ))
  (define (NUMBER? val)
    (or (number? val)
        (and (symbol? val)
             ;; prefix with 0x or 0X
             (let ((str (symbol->string val)))
               (regexp-match #rx"^0[Xx][0-9a-fA-F]+$" str)))))  
  (define (MAKE-NUMBER val)
    ;; 要么是数字，要么去掉其中所有非数字部分是十六进制数，要么报错
    (if (number? val)
        val
        (let ((str (symbol->string val)))
          ;; 去掉其中所有非十六进制数字部分
          (let ((hex-str (regexp-replace* #rx"[^0-9a-fA-F]" str "")))
            (if (> (string-length hex-str) 0)
                (string->number hex-str 16)
                (error (format "CANNOT SEE ~a TO BE NUMBER!" val)))))))
  
  (define (label? val)
    (and (symbol? val)
         (let ((cur-str (symbol->string val)))
           (char=? #\: (string-ref cur-str (- (string-length cur-str) 1))))))

  (define (instruction? val)
    (assoc val ISA))

  (let* ((list-of-code (map
                        (lambda (v)
                          (if (symbol? v)
                              (string->symbol (string-upcase (symbol->string v)))
                              v))
                        list-of-code))
         (labels
          (let loop ((i 0)
                     (L list-of-code)
                     (result '()))
            (cond ((null? L)
                   result)
                  ((label? (car L))
                   (let* ((cur (car L))
                          (cur-str (symbol->string (car L)))
                          (cur-str-no-colon (string-drop-right cur-str 1)))
                     (loop i (cdr L) (cons `(,(string->symbol cur-str-no-colon) ,i) result))))
                  (else
                   (loop (+ i 1) (cdr L) result))))))
    (let loop ((L list-of-code)
               (reversed-result '()))
      (if (null? L)
          (list->vector (reverse reversed-result))
          (let ((cur-val (car L)))
            (cond
              ((NUMBER? cur-val)
               (loop (cdr L) (cons (MAKE-NUMBER cur-val) reversed-result)))
              ((instruction? cur-val)
               (let* ((instr-item (assoc cur-val ISA))
                      (instr-name (car instr-item))
                      (instr-code (cadr instr-item))
                      (arg-num    (caddr instr-item)))
                 (if (= 0 arg-num)
                     (loop (cdr L) (cons instr-code reversed-result))
                     (loop (cddr L)
                           (cons (if (NUMBER? (cadr L))
                                     (MAKE-NUMBER (cadr L))
                                     (let ((label-item  (assoc (cadr L) labels)))
                                       (if label-item
                                           (cadr label-item)
                                           (error `(error: unkown label ,(cadr L) in instr (,(car L) ,(cadr L)))))))
                                 (cons (cadr (assoc cur-val ISA)) reversed-result))))))
              ((assoc cur-val ALIAS_MAP)
               (let ((cur-instr-name (cadr (assoc cur-val ALIAS_MAP))))
                 (loop (cons cur-instr-name (cdr L)) reversed-result)))
              ((label? cur-val)
               (loop (cdr L) reversed-result))
              ((assoc cur-val labels) ; taget?
               (loop (cdr L) (cons (cadr (assoc cur-val labels)) reversed-result)))
              (else ; unkown symbol
               (error `(error: unkown symbol: ,cur-val)))))))))

(define LOAD-BYTECODE!
  (lambda (BYTE-CODE)
    (vector-copy! MEM CODE-SEG-BEGIN BYTE-CODE)
    (dump-machine)))


(define debug-output-port #f)
(define (ensure-debug-output-port)
  (when (or (not debug-output-port) (port-closed? debug-output-port))
    (set! debug-output-port (open-output-file (get-debug-print-file-name) #:exists 'append))))
(define (debug-print)
  (define dasm-list
    (map
     (lambda (item)
       `(,(cadr item) ,(car item)))
     ISA))

  (ensure-debug-output-port)
  
  (let* ((instr (get-instr))
         (item  (assoc instr cdr-mapped-ISA)))
    (display (format "~a\n"
                     `(CYCLES: ,CYCLES PC: ,PC SP: ,SP
                               REGSTACK:
                               ,(build-vector STACK-LIMIT
                                              (lambda (n)
                                                (if (= n SP)
                                                    `(,(reg-ref n))
                                                    (reg-ref n))))
                               instr:  ,(if (assoc instr dasm-list)
                                            `(,(cadr (assoc instr dasm-list))
                                              ,@(build-list
                                                 (cadr item)
                                                 (lambda (i) (get-arg (+ i 1)))))
                                            `(UNKNOW OPCODE: (,(read-code PC)))
                                         )))
             debug-output-port)
    (flush-output debug-output-port)))


(define (step-machine!)
  (let* ((instr (get-instr))
         (item  (assoc instr cdr-mapped-ISA)))
    (debug-print)
    (cond (item ; 有这指令
           ((caddr item)))
          (else ; 没这指令
           (pc+! 1))))
  (set! COINS-REMAIN (- COINS-REMAIN 1))
  (set! CYCLES (+ 1 CYCLES)))

(define (RESET-MACHINE!)
  (reset-pc!)
  (set-sp! -1)
  (reset-cycles!)
  ;; 将代码段都设为255
  (for ([i (in-range CODE-SEG-BEGIN (+ CODE-SEG-BEGIN CODE-SEG-LEN))])
    (vector-set! MEM i 255))
  ;; 将数据段都设为0
  (for ([i (in-range DATA-SEG-BEGIN (+ DATA-SEG-BEGIN DATA-SEG-LEN))])
    (vector-set! MEM i 0))
  ;; 将framebuffer都设为32
  (for ([i (in-range FRAME-BUFFER-BEGIN (+ FRAME-BUFFER-BEGIN (* FRAME-BUFFER-WIDTH FRAME-BUFFER-HEIGHT)))])
    (vector-set! MEM i 32))
  (LOAD-BYTECODE! (ASSEMBLE (make-test-code)))
  (dump-machine)(render-frame-buffer))

(define (RUN-MACHINE!)
  (load-machine!)
  (with-output-to-file (get-debug-print-file-name)
    (lambda ()
      (set! debug-output-port (current-output-port))
      (let loop ()
        (cond ((<= COINS-REMAIN 0)          ; 没coin了
               (displayln 'NOT-ENOUGH-COINS)
               (dump-machine)(render-frame-buffer)
               PC)
              ((>= PC MEM-LEN)
               (begin
                 (set-pc! 0)
                 (loop)))
              ((eq? (get-instr) HALT-OPCODE)
               (step-machine!)
               (dump-machine)(render-frame-buffer)
               PC)
              (else
               (step-machine!)
               (loop)))))
    #:exists 'replace))



(define (get-state) `((COINS-REMAIN ,COINS-REMAIN)
                      (CYCLES             ,CYCLES)
                      (PC                     ,PC)
                      (SP                     ,SP)
                      (REGSTACK         ,REGSTACK)
                      (MEM                   ,MEM)))
 
(define (load-machine!)
  (when (file-exists? dump-file-name)
    (let ((context (with-input-from-file dump-file-name read)))
      (set! COINS-REMAIN (if (assoc 'COINS-REMAIN context) (cadr (assoc 'COINS-REMAIN context)) COINS-REMAIN))
      (set! CYCLES       (if (assoc 'CYCLES       context) (cadr (assoc 'CYCLES       context)) CYCLES      ))
      (set! PC           (if (assoc 'PC           context) (cadr (assoc 'PC           context)) PC          ))
      (set! SP           (if (assoc 'SP           context) (cadr (assoc 'SP           context)) SP          ))
      (set! REGSTACK     (if (assoc 'REGSTACK     context) (cadr (assoc 'REGSTACK     context)) REGSTACK    ))
      (set! MEM          (if (assoc 'MEM          context) (cadr (assoc 'MEM          context)) MEM         )))))

(define (dump-machine)
  (with-output-to-file dump-file-name
    (lambda ()
      (write (get-state)))
    #:exists 'replace))



(define (make-test-code)
  (let ((* (char->integer #\*))
        (╔ (char->integer #\╔))
        (╗ (char->integer #\╗))
        (╝ (char->integer #\╝))
        (╚ (char->integer #\╚))
        (═ (char->integer #\═))
        (║ (char->integer #\║))
        (addr-n           0)
        (addr-x           1)
        (addr-y           2)
        (addr-dir         3))
    `(
      ;; 设置曲线的阶数
      p ,addr-n   p 2  store
      ;; set x in addr 0
      p ,addr-x   p 32 store
      ;; set y in addr 1
      p ,addr-y   p 32 store
      ;; set direction 0=right 1=up 2=left 3=down in addr 2
      p ,addr-dir p 0 store

      ;; main
         call B
         halt
      A: p ,addr-n load p 0 eq jumpif END-A
         p ,addr-n p ,addr-n load dec store  ; 深度-1
         call T- call B call F call T+ call A
         call F
         call A  call T+ call F call B call T-
         p ,addr-n p ,addr-n load inc store  ; 深度恢复
      END-A:  ret
      B: p ,addr-n load p 0 eq jumpif END-B
         p ,addr-n p ,addr-n load dec store  ; 深度-1
         call T+
         call A call F
         call T-
         call B
         call F
         call B  call T- call F call A call T+
         p ,addr-n p ,addr-n load inc store  ; 深度恢复
      END-B: ret
      F:     p ,addr-dir load p 0 neq jumpif 1? call east  ret
      1?:    p ,addr-dir load p 1 neq jumpif 2? call north ret
      2?:    p ,addr-dir load p 2 neq jumpif 3? call west  ret
      3?:                                       call south ret
          east:  call DRAW═ call x++ call DRAW═  ret
          north: call DRAW║ call y++ call DRAW║  ret
          west:  call DRAW═ call x-- call DRAW═  ret
          south: call DRAW║ call y-- call DRAW║  ret
      ;; 修改 T+ 和 T- 以绘制拐角
      T+:  call DRAW_CORNER_T+ call d++ ret
      T-:  call DRAW_CORNER_T- call d-- ret
      ;; 绘制逆时针转向的拐角
      DRAW_CORNER_T+:
                      p ,addr-dir load p 0 eq callif T+0
                      p ,addr-dir load p 1 eq callif T+1
                      p ,addr-dir load p 2 eq callif T+2
                      p ,addr-dir load p 3 eq callif T+3
                      ret
      T+0: call DRAW╚ ret  ; 从右到上
      T+1: call DRAW╝ ret  ; 从上到左
      T+2: call DRAW╗ ret  ; 从左到下
      T+3: call DRAW╔ ret  ; 从下到右
      ;; 绘制顺时针转向的拐角
      DRAW_CORNER_T-:
                      p ,addr-dir load p 0 eq callif T-0
                      p ,addr-dir load p 1 eq callif T-1
                      p ,addr-dir load p 2 eq callif T-2
                      p ,addr-dir load p 3 eq callif T-3
                      ret
      T-0: call DRAW╔ ret  ; 从右到下
      T-1: call DRAW╚ ret  ; 从上到右
      T-2: call DRAW╝ ret  ; 从左到上
      T-3: call DRAW╗ ret  ; 从下到左
      DRAW*: p ,addr-x load p ,addr-y load p ,* setu ret
      DRAW╔: p ,addr-x load p ,addr-y load p ,╔ setu ret
      DRAW╗: p ,addr-x load p ,addr-y load p ,╗ setu ret
      DRAW╝: p ,addr-x load p ,addr-y load p ,╝ setu ret
      DRAW╚: p ,addr-x load p ,addr-y load p ,╚ setu ret
      DRAW═: p ,addr-x load p ,addr-y load p ,═ setu ret
      DRAW║: p ,addr-x load p ,addr-y load p ,║ setu ret
      x++:   p ,addr-x p ,addr-x load inc   store ret
      x--:   p ,addr-x p ,addr-x load dec   store ret
      y++:   p ,addr-y p ,addr-y load dec   store ret
      y--:   p ,addr-y p ,addr-y load inc   store ret
      d++:   p ,addr-dir p ,addr-dir load inc p 4 mod store ret
      d--:   p ,addr-dir p ,addr-dir load dec p 4 mod store ret
      debug:
             p ,addr-n   load print
             p ,addr-x   load print
             p ,addr-y   load print
             p ,addr-dir load print
             ret
      ))
  )

(module+ main
  (RESET-MACHINE!)
  (set-coins! (* 6 8196))
  (RUN-MACHINE!)
  #|
  (require racket/repl)
  (require xrepl)
  (define-namespace-anchor a)  ; 创建命名空间锚点
  (parameterize ([current-namespace (namespace-anchor->namespace a)])
  (displayln "现在你可以在REPL中调用 (RUN-MACHINE),(render-frame-buffer),(insert-coin n)等等东西了")
  (read-eval-print-loop))
  |#
  )
